(in-package #:experiment)

(defvar *action-list* nil
  "A list of all actions that are possible. To discover what actions
are defined for a state, one must walk this list and check each one.")

(defgeneric state-matches-p (name state &key)
  (:documentation "NAME is the name of the matcher. It's used in
define-action to identify which state matchers are needed as
preconditions for the action. It should be a symbol.

The return value can be used in DEFINE-ACTION's body, so return
something relevant."))

(defgeneric event-matches-p (name state event keys)
  (:documentation "NAME is the name of the event matcher. It should be
a symbol. It's used in define-action to identify which event matcher
to use to identify if EVENT matches."))

(defgeneric action-match-values (state action event)
  (:documentation "Return the values returned by the state match
functions and event match function for the action NAME. Return NIL if
the event or one of the state matchers does not match."))

(defgeneric execute-action (name state keys)
  (:documentation "Use the match values stored as a plist in KEYS to
execute the action NAME."))

(defgeneric action-match-structure (name state)
  (:documentation "Returns the action structure for the action named NAME in STATE."))

(defgeneric all-state-actions (state)
  (:method-combination progn :most-specific-last)
  (:documentation "Return the names of all the actions that are
defined for the given state."))

(defmacro define-event-match (name (state event &rest keys) &body body)
  (u:with-gensyms (name-parm keys-param)
    `(defmethod event-matches-p ((,name-parm (eql ',name)) ,state ,event ,keys-param)
       ;; (when (progn ,@body)
       ;;   ,event)
       (destructuring-bind (&key ,@(mapcar (lambda (key)
                                             (list key
                                                   nil
                                                   (intern (format nil "~a~a" key '-supplied (symbol-package key)))))
                                           keys)) ,keys-param
         (declare (ignorable ,@keys))
      ,@body))))

(defmacro define-state-match (name (state &rest keys) &body body)
  (u:with-gensyms (name-parm)
    `(defmethod state-matches-p ((,name-parm (eql ',name)) ,state
                                 &key ,@(mapcar (lambda (key)
                                                  (list key
                                                        nil
                                                        (intern (format nil "~a~a" key '-supplied) (symbol-package key))))
                                                keys))
       ,@body)))

(defmethod action-match-structure (action state)
  nil)

(defstruct match-template
  name var key values)

(defmethod make-load-form ((obj match-template) &optional env)
  (declare (ignore env))
  `(make-match-template :name ',(match-template-name obj)
                        :var ',(match-template-var obj)
                        :key ',(match-template-key obj)
                        :values ',(match-template-values obj)))

(defstruct action
  name
  event-match-template
  state-match-templates)

(defmethod make-load-form ((obj action) &optional env)
  (declare (ignore env))
  `(make-action :name ',(action-name obj)
                :event-match-template ,(action-event-match-template obj)
                :state-match-templates ',(action-state-match-templates obj)))

(defun make-action-struct (name event-match state-matches)
  (labels ((make-template (match)
             (destructuring-bind (&key var key &allow-other-keys)
                 (cdr match)
               (let ((values (copy-list (cdr match))))
                 (remf values :var)
                 (remf values :key)
                 (make-match-template :name (first match)
                                      :var var
                                      :key (or key
                                               (when var
                                                 (intern (string var) :keyword)))
                                      :values values)))))
    (make-action :name name
                 :event-match-template (make-template event-match)
                 :state-match-templates (mapcar #'make-template state-matches))))

(defun action-match-keys (action)
  (labels ((get (template)
             (when (match-template-var template)
               `((( ,(match-template-key template)
                    ,(match-template-var template)))))))
    (append (get (action-event-match-template action))
            (mapcan #'get (action-state-match-templates action)))))

(defmacro define-action (name ((state state-class) event-match &rest state-matches) &body body)
  (u:with-gensyms (name-param keys-param)
    (let* ((action (make-action-struct name event-match state-matches))
           (keys (action-match-keys action)))
      `(progn
         (defmethod execute-action ((,name-param (eql ',name))
                                    (,state ,state-class)
                                    ,keys-param)
           (destructuring-bind (&key ,@keys) ,keys-param
             ,@body
             (values)))
         (defmethod action-match-structure ((,name-param (eql ',name)) (,state ,state-class))
           ,action)
         (pushnew ',name *action-list*)))))

(defmethod event-matches-p (name state event keys)
  nil)

(defun action-states-match (action state)
  (every (lambda (match)
           (apply 'state-matches-p (match-template-name match) state (match-template-values match)))
         (action-state-match-templates action)))

(defun action-states-values (action state)
  (mapcan (lambda (match)
            (let ((v (apply 'state-matches-p (match-template-name match)
                            state
                            (match-template-values match))))
              (unless v
                (return-from action-states-values nil))
              (when (match-template-key match)
                (list (match-template-key match) v))))
          (action-state-match-templates action)))

(defmethod action-match-values (state action-name event)
  "Returns NIL if there is no match. Generate the keywords and values
to be passed to execute-action for the action, NAME."
  (let ((action (action-match-structure action-name state)))
    (when action
      ;; (print `(action-match ,(action-name action)))
      (let* ((event-tmpl (action-event-match-template action))
             (ev (or (funcall 'event-matches-p (match-template-name event-tmpl)
                              state event (match-template-values event-tmpl))
                     (progn ;; (print `(event-match-fail))
                            nil)
                     (return-from action-match-values nil)))
             (sv (mapcar (lambda (match)
                           (or (apply 'state-matches-p (match-template-name match) state (match-template-values match))
                               (progn ;; (print `(state-match-fail))
                                      nil)
                               (return-from action-match-values nil)))
                         (action-state-match-templates action))))
        (append
         (list (action-name action))
         (when (match-template-key event-tmpl)
           (list (match-template-key event-tmpl) ev))
         (mapcan (lambda (template value)
                   (when (match-template-key template)
                     (list (match-template-key template)
                           value)))
                 (action-state-match-templates action)
                 sv))))))

(defun possible-actions (state)
  "Return the actions for STATE whose state matchers match and leave
the event matcher's value blank. This is used by DUMP-ACTIONS."
  (labels ((match (state-matches)
             (every (lambda (sm)
                      (apply 'state-matches-p (first sm) state (cdr sm)))
                    state-matches)))
    (loop for name in *action-list*
       for a = (action-match-structure name state)
       ;;for event-tmpl = (action-event-match-template a)
       ;; for state-tmpls = (action-state-match-templates a)
       when (and a (action-states-match a state)
                 ;; better way to find out if a symbol is external?
                 (multiple-value-bind (sym status)
                     (find-symbol (symbol-name (action-name a))
                                  (symbol-package (action-name a)))
                   (eq status :external)))
       collect (let ((event-tmpl (action-event-match-template a)))
                 ;; (print `(possible-actions ,a))
                 (list* (action-name a)
                        (when (match-template-key event-tmpl)
                          (list (match-template-key event-tmpl) :value-needed))
                        ;; (mapcan (lambda (template value)
                        ;;           (when (match-template-key template)
                        ;;             (list (match-template-key template)
                        ;;                   value)))
                        ;;         state-matches)
                        )))))

(defun possible-actions-for-event (state event action-list)
  "Return the values needed for execute-action for each action that
matches the state and event."
  (loop for a in action-list
     for keys = (action-match-values state a event)
     when keys
     collect keys))

(defun match-event-execute-actions (state event)
  "Find the actions that match the event and state and execute each
one. Returns the number of actions executed or NIL if none were
executed."
  (let ((actions (possible-actions-for-event state event *action-list*)))
    ;; (print `(match? ,actions))
    (when actions
      (dolist (a actions)
        ;; (print `(match ,a))
        (execute-action (car a) state (cdr a)))
      (length actions))))
